home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / boot / core.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  3.3 KB  |  106 lines
  1. (* Copyright 1989 by AT&T Bell Laboratories *)
  2. (*
  3. The following are already in the symbol table:
  4.      1) Magical words that can be free in signatures (from PrimTypes):
  5.         int string bool unit real list array ref exn
  6.      2) Built-in constructors (from PrimTypes):
  7.         :: nil ref true false
  8.      3) Built-in structures:
  9.         PrimTypes InLine
  10.     The InLine structure is not typed (all values have type alpha).
  11. All matches in this file should be exhaustive; the match and bind exceptions
  12.  are not defined at this stage of bootup, so any uncaught match will cause
  13.  an unpredictable error.
  14. *)
  15.  
  16.  
  17. functor CoreFunc (Assembly : ASSEMBLY) =
  18.   struct
  19.     structure Assembly = Assembly
  20.  
  21.     exception Bind
  22.     exception Match
  23.  
  24.     exception Ord            (* for strings, bytearray update bounds check *)
  25.     exception Range          (* for bytearray update *)
  26.     exception Subscript      (* for vectors *)
  27.     exception RealSubscript    (* for floating arrays *)
  28.  
  29.     local exception NoProfiler
  30.     in val profile_register =
  31.       ref(fn s:string => (raise NoProfiler):int*int array*int ref)
  32.     end
  33.  
  34.     val current = Assembly.current  (* get rid of this *)
  35.     val toplevel = Assembly.A.create_b 18  (* get rid of this *)
  36.  
  37.     val getDebugf = ref (fn ()=>())
  38.  
  39.     val forcer_p = ref (fn () => ())
  40.  
  41.     fun getDebug x = InLine.! getDebugf x
  42.  
  43.     val vector0 = Assembly.vector0  (* needed to compile ``#[]'' *)
  44.     val errorMatch = ref ""
  45.  
  46.     fun stringequal(a,b) =
  47.       if InLine.ieql(a,b) then true
  48.         else InLine.boxed a andalso InLine.boxed b andalso
  49.           let val len = InLine.length a
  50.         in if InLine.ieql(len,InLine.length b)
  51.           then let
  52.             fun f 0 = true
  53.               | f i = let val j = InLine.-(i,1)
  54.                   in if InLine.ieql(InLine.ordof(a,j), InLine.ordof(b,j))
  55.                        then f j else false
  56.                   end
  57.             in f len end
  58.           else false
  59.         end
  60.  
  61.     local
  62.       val ieql = InLine.ieql and ineq = InLine.ineq and feql = InLine.feql
  63.       val cast = InLine.cast and sub = InLine.subscript
  64.       val getObjTag = InLine.gettag and boxed = InLine.boxed and op * = InLine.*
  65.       val op + = InLine.+ and op - = InLine.-
  66.     in
  67.       fun polyequal (a : 'a, b : 'a) =
  68.         ieql(a, b)
  69.         orelse (boxed a andalso boxed b
  70.           andalso let
  71.         val aTag = getObjTag a
  72.         fun pairEq () = let val bTag = getObjTag b
  73.               in
  74.             (ieql(bTag, 0x02) orelse ineq(InLine.andb(bTag, 0x3), 0x2))
  75.               andalso polyequal(sub(a,0), sub(b,0))
  76.               andalso polyequal(sub(a,1), sub(b,1))
  77.               end
  78.         in
  79.           case aTag
  80.            of 0x02 (* tag_pair *) => pairEq()
  81.             | 0x06 (* tag_reald *) => feql(a, b)
  82.             | 0x0a (* tag_embedded_reald *) => feql(a, b)
  83.             | 0x12 (* tag_special *) => false
  84.             | 0x22 (* tag_record *) => if ieql(getObjTag b, aTag)
  85.             then let
  86.               val lenm1 = (InLine.length a) - 1
  87.               fun m (j : int) = if ieql(j, lenm1)
  88.                 then polyequal(sub(a,j), sub(b,j))
  89.                 else polyequal(sub(a,j), sub(b,j)) andalso m(j + 1)
  90.               in
  91.                 m 0
  92.               end
  93.             else false
  94.             | 0x26 (* tag_array *) => false
  95.             | 0x2a (* tag_string *) => stringequal(cast a, cast b)
  96.             | 0x2e (* tag_embedded_string *) => stringequal(cast a, cast b)
  97.             | 0x32 (* tag_bytearray *) => false
  98.             | 0x36 (* tag_realdarray *) => false
  99.             | _ (* tagless pair *) => pairEq()
  100.           (* end case *)
  101.         end)
  102.    end (* local *)
  103.        val profile_sregister = ref(fn (x:Assembly.object,s:string)=>x)
  104.  
  105. end (* CoreFunc *)
  106.